home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / message / messag / mdimain.fr_ / mdimain.fr
Text File  |  1995-01-14  |  18KB  |  509 lines
  1. VERSION 2.00
  2. Begin MDIForm MDImain 
  3.    Caption         =   "Message.VBX Demo"
  4.    ClientHeight    =   4950
  5.    ClientLeft      =   420
  6.    ClientTop       =   1770
  7.    ClientWidth     =   8760
  8.    Height          =   5640
  9.    Icon            =   MDIMAIN.FGX:0000
  10.    Left            =   360
  11.    LinkTopic       =   "MDIForm1"
  12.    Top             =   1140
  13.    Width           =   8880
  14.    Begin PictureBox PicStatus 
  15.       Align           =   2  'Align Bottom
  16.       BackColor       =   &H00C0C0C0&
  17.       BorderStyle     =   0  'None
  18.       Height          =   420
  19.       Left            =   0
  20.       ScaleHeight     =   420
  21.       ScaleWidth      =   8760
  22.       TabIndex        =   0
  23.       Top             =   4530
  24.       Width           =   8760
  25.       Begin Timer Timer1 
  26.          Interval        =   500
  27.          Left            =   3000
  28.          Top             =   0
  29.       End
  30.       Begin Message Message1 
  31.          Left            =   2520
  32.          Top             =   0
  33.       End
  34.       Begin Label LblSBcaps 
  35.          Alignment       =   2  'Center
  36.          BackStyle       =   0  'Transparent
  37.          Caption         =   "CAPS"
  38.          FontBold        =   0   'False
  39.          FontItalic      =   0   'False
  40.          FontName        =   "Arial"
  41.          FontSize        =   8.25
  42.          FontStrikethru  =   0   'False
  43.          FontUnderline   =   0   'False
  44.          Height          =   225
  45.          Left            =   7260
  46.          TabIndex        =   5
  47.          Top             =   100
  48.          Width           =   615
  49.       End
  50.       Begin Label LblSBnum 
  51.          Alignment       =   2  'Center
  52.          BackStyle       =   0  'Transparent
  53.          Caption         =   "NUM"
  54.          FontBold        =   0   'False
  55.          FontItalic      =   0   'False
  56.          FontName        =   "Arial"
  57.          FontSize        =   8.25
  58.          FontStrikethru  =   0   'False
  59.          FontUnderline   =   0   'False
  60.          Height          =   225
  61.          Left            =   7980
  62.          TabIndex        =   4
  63.          Top             =   100
  64.          Width           =   615
  65.       End
  66.       Begin Label LblSBdate 
  67.          Alignment       =   2  'Center
  68.          BackStyle       =   0  'Transparent
  69.          Caption         =   "12/25/96"
  70.          FontBold        =   0   'False
  71.          FontItalic      =   0   'False
  72.          FontName        =   "Arial"
  73.          FontSize        =   8.25
  74.          FontStrikethru  =   0   'False
  75.          FontUnderline   =   0   'False
  76.          Height          =   225
  77.          Left            =   4920
  78.          TabIndex        =   3
  79.          Top             =   100
  80.          Width           =   795
  81.       End
  82.       Begin Label LblSBtime 
  83.          Alignment       =   2  'Center
  84.          BackStyle       =   0  'Transparent
  85.          Caption         =   "00:00"
  86.          FontBold        =   0   'False
  87.          FontItalic      =   0   'False
  88.          FontName        =   "Arial"
  89.          FontSize        =   8.25
  90.          FontStrikethru  =   0   'False
  91.          FontUnderline   =   0   'False
  92.          Height          =   225
  93.          Left            =   4020
  94.          TabIndex        =   2
  95.          Top             =   105
  96.          Width           =   795
  97.       End
  98.       Begin Label LblStatus 
  99.          BackStyle       =   0  'Transparent
  100.          Caption         =   "Menu Status Goes Here..."
  101.          FontBold        =   0   'False
  102.          FontItalic      =   0   'False
  103.          FontName        =   "Arial"
  104.          FontSize        =   8.25
  105.          FontStrikethru  =   0   'False
  106.          FontUnderline   =   0   'False
  107.          Height          =   225
  108.          Left            =   120
  109.          TabIndex        =   1
  110.          Top             =   100
  111.          Width           =   3795
  112.       End
  113.    End
  114.    Begin Menu mnuDemos 
  115.       Caption         =   "&Demos"
  116.       Begin Menu mnuDemosMoveForm 
  117.          Caption         =   "Moving Captionless &Form..."
  118.       End
  119.       Begin Menu mnuDemosMoveControl 
  120.          Caption         =   "Moving &Controls..."
  121.       End
  122.       Begin Menu mnuDemosSep01 
  123.          Caption         =   "-"
  124.       End
  125.       Begin Menu mnuDemosExit 
  126.          Caption         =   "E&xit"
  127.       End
  128.    End
  129.    Begin Menu mnuHelp 
  130.       Caption         =   "&Help"
  131.       Begin Menu mnuHelpContents 
  132.          Caption         =   "VBX Help &Contents..."
  133.       End
  134.       Begin Menu mnuHelpSearch 
  135.          Caption         =   "VBX Help &Search..."
  136.       End
  137.       Begin Menu mnuHelpSep01 
  138.          Caption         =   "-"
  139.       End
  140.       Begin Menu mnuHelpAbout 
  141.          Caption         =   "&About..."
  142.       End
  143.       Begin Menu mnuHelpSep02 
  144.          Caption         =   "-"
  145.       End
  146.       Begin Menu mnuHelpCatalog 
  147.          Caption         =   "Catalog of &Products..."
  148.       End
  149.       Begin Menu mnuHelpReg 
  150.          Caption         =   "Online &Registration..."
  151.       End
  152.       Begin Menu mnuHelpOrder 
  153.          Caption         =   "&Order Form..."
  154.       End
  155.       Begin Menu mnuHelpEval 
  156.          Caption         =   "&Evaluation Form..."
  157.       End
  158.       Begin Menu mnuHelpShareware 
  159.          Caption         =   "Shareware &Information..."
  160.       End
  161.    End
  162. End
  163.  
  164. Sub DoPicChild3D (Obj As Control, Style, thick)
  165. 'draws 3D shadows effects around a control
  166. 'Style is either "sunken" or "raised"
  167.  
  168. 'use this function in the Paint event of the form
  169.  
  170.     If thick <= 0 Then thick = 1
  171.     If thick > 8 Then thick = 8
  172.     OldMode = Obj.Parent.PicStatus.ScaleMode
  173.     OldWidth = Obj.Parent.PicStatus.DrawWidth
  174.     Obj.Parent.PicStatus.ScaleMode = 3
  175.     Obj.Parent.PicStatus.DrawWidth = 1
  176.     ObjHeight = Obj.Height
  177.     ObjWidth = Obj.Width
  178.     ObjLeft = Obj.Left
  179.     ObjTop = Obj.Top
  180.     
  181.     Select Case LCase$(Style)
  182.         Case "sunken":
  183.             TLshade = QBColor(8)
  184.             BRshade = QBColor(15)
  185.         Case "raised":
  186.             TLshade = QBColor(15)
  187.             BRshade = QBColor(8)
  188.         End Select
  189.         For i = 1 To thick
  190.             CurLeft = ObjLeft - i
  191.             CurTop = ObjTop - i
  192.             CurWide = ObjWidth + (i * 2) - 1
  193.             CurHigh = ObjHeight + (i * 2) - 1
  194.             Obj.Parent.PicStatus.Line (CurLeft, CurTop)-Step(CurWide, 0), TLshade
  195.             Obj.Parent.PicStatus.Line -Step(0, CurHigh), BRshade
  196.             Obj.Parent.PicStatus.Line -Step(-CurWide, 0), BRshade
  197.             Obj.Parent.PicStatus.Line -Step(0, -CurHigh), TLshade
  198.             Next i
  199.         If thick > 2 Then
  200.             CurLeft = ObjLeft - thick - 1
  201.             CurTop = ObjTop - thick - 1
  202.             CurWide = ObjWidth + ((thick + 1) * 2) - 1
  203.             CurHigh = ObjHeight + ((thick + 1) * 2) - 1
  204.             Obj.Parent.PicStatus.Line (CurLeft, CurTop)-Step(CurWide, 0), QBColor(0)
  205.             Obj.Parent.PicStatus.Line -Step(0, CurHigh), QBColor(0)
  206.             Obj.Parent.PicStatus.Line -Step(-CurWide, 0), QBColor(0)
  207.             Obj.Parent.PicStatus.Line -Step(0, -CurHigh), QBColor(0)
  208.             End If
  209.     Obj.Parent.PicStatus.ScaleMode = OldMode
  210.     Obj.Parent.PicStatus.DrawWidth = OldWidth
  211. End Sub
  212.  
  213. Sub MDIForm_Load ()
  214.     Screen.MousePointer = 11
  215.     FormCenterScreen Me
  216.     initialize
  217.     LblStatus.Caption = ""
  218.     LblSBtime.Caption = ""
  219.     LblSBdate.Caption = ""
  220.     
  221.     'define the hWnd for Message to Receive messages from
  222.     Message1.hWindow = Me.hWnd
  223.     'now define the various message we want to intercept
  224.     Message1.Status(WM_MenuSelect) = True       'for menu dragging messages
  225.     Message1.Status(WM_SysCommand) = True       'for custom sysmenu item responses and messages
  226.     Message1.Status(WM_GetMinMaxInfo) = True    'to set minimum and maximum form resize
  227.  
  228.     'add a new system menu item
  229.     SysMenuAppendLine Me, 2000
  230.     SysMenuAppendMsg Me, "This is test #&1...", 2001
  231.     SysMenuAppendMsg Me, "This is test #&2...", 2002
  232.     SysMenuAppendMsg Me, "This is test #&3...", 2003
  233.  
  234.     mnuhelp.Caption = Chr$(8) + mnuhelp.Caption
  235.     Timer1_Timer
  236.     FirstMsg.Show
  237.     Screen.MousePointer = 0
  238. End Sub
  239.  
  240. Sub Message1_Receive (Msg As Integer, wParam As Integer, lParam As Long, UseRetVal As Integer, RetVal As Long)
  241.     
  242.     If Msg = WM_MenuSelect Then 'menu message
  243.         If wParam < 0 Then
  244.             'system menu
  245.             Select Case wParam  'these are standard SysMenu wParam codes
  246.                 Case -3808: SBmsg$ = "Restore the demo window size"
  247.                 Case -4080: SBmsg$ = "Move the demo window"
  248.                 Case -4096: SBmsg$ = "Change the demo window size"
  249.                 Case -4064: SBmsg$ = "Minimize the demo to an icon"
  250.                 Case -4048: SBmsg$ = "Maximize the demo window"
  251.                 Case -4000: SBmsg$ = "Close the demo application"
  252.                 Case -3792: SBmsg$ = "Display the task list"
  253.                 End Select
  254.             LblStatus.Caption = " " + SBmsg$
  255.             Exit Sub
  256.             'no item selected
  257.             ElseIf wParam = 0 And lParam = 65535 Then
  258.                 LblStatus.Caption = ""
  259.                 Exit Sub
  260.             'respond to custom sysmenu dragging
  261.             ElseIf wParam = 2001 Then
  262.                 LblStatus.Caption = " This is test #1 in action"
  263.                 Exit Sub
  264.             ElseIf wParam = 2002 Then
  265.                 LblStatus.Caption = " This is test #2 in action"
  266.                 Exit Sub
  267.             ElseIf wParam = 2003 Then
  268.                 LblStatus.Caption = " This is test #3 in action"
  269.                 Exit Sub
  270.             Else
  271.             'normal menu items
  272.             hMenu% = GetMenu(Me.hWnd)
  273.             ReturnString$ = Space$(255)
  274.             ret% = GetMenuString(hMenu%, wParam, ReturnString$, 255, 0)
  275.             ReturnString$ = TrimAtNull(ReturnString$)
  276.             'remove any Shortcut key text
  277.             pos% = InStr(ReturnString$, Chr$(9))
  278.             If pos% <> 0 Then ReturnString$ = Left$(ReturnString$, pos% - 1)
  279.             'now ReturnString$=the actual menu item text (including any ampersands)
  280.             Select Case ReturnString$
  281.                 Case "Moving Captionless &Form...": SBmsg$ = "How to implement a moveable captionless form"
  282.                 Case "Moving &Controls...": SBmsg$ = "How to move controls at run-time"
  283.                 Case "E&xit": SBmsg$ = "End the Message.VBX demo"
  284.                 Case "VBX Help &Contents...": SBmsg$ = "Display contents page of Message.HLP"
  285.                 Case "VBX Help &Search...": SBmsg$ = "Start Message.HLP with a topical search"
  286.                 Case "&About...": SBmsg$ = "Copyright message window"
  287.                 Case "Catalog of &Products...": SBmsg$ = "Get our shareware catalog"
  288.                 Case "Online &Registration...": SBmsg$ = "Instructions for registering through CIS"
  289.                 Case "&Order Form...": SBmsg$ = "Get an Order Form for printing"
  290.                 Case "&Evaluation Form...": SBmsg$ = "Get our product Evaluation Form"
  291.                 Case "Shareware &Information...": SBmsg$ = "Get information on shareware"
  292.                 End Select
  293.             LblStatus.Caption = " " + SBmsg$
  294.             Exit Sub
  295.             End If
  296.     End If
  297.     If Msg = WM_GetMinMaxInfo Then 'set min/max window dimensions
  298.         Dim MinMax As MinMaxInfo
  299.         MessageDataGet lParam, Len(MinMax), MinMax
  300.             ScreenWide% = (Screen.Width / Screen.TwipsPerPixelX) - 20
  301.             ScreenHigh% = (Screen.Height / Screen.TwipsPerPixelY) - 20
  302.             MinMax.ptMaxSize.x = ScreenWide%    'when maximized
  303.             MinMax.ptMaxSize.y = ScreenHigh%    'when maximized
  304.             MinMax.ptMaxPosition.x = 10         'when maximized
  305.             MinMax.ptMaxPosition.y = 0          'when maximized
  306.             MinMax.ptMaxTrackSize.x = ScreenWide%   'when normal
  307.             MinMax.ptMaxTrackSize.y = ScreenHigh%   'when normal
  308.             MinMax.ptMinTrackSize.x = 496           'when normal
  309.             MinMax.ptMinTrackSize.y = 300           'when normal
  310.         MessageDataSet lParam, Len(MinMax), MinMax
  311.         UseRetVal = 1'use our own return value
  312.         RetVal = 0
  313.         End If
  314.     If Msg = WM_SysCommand Then 'system menu click
  315.         If wParam = 2001 Then
  316.             TheMsg$ = "This is test #1..." + nl + nl
  317.             TheMsg$ = TheMsg$ + "You can do anything here."
  318.             MsgBox TheMsg$, 48, "Custom System Menu Response"
  319.             End If
  320.         If wParam = 2002 Then
  321.             TheMsg$ = "This is test #2..." + nl + nl
  322.             TheMsg$ = TheMsg$ + "You can do anything here too." + nl + nl
  323.             TheMsg$ = TheMsg$ + "'This is test #1' is DISABLED!"
  324.             MsgBox TheMsg$, 48, "Custom System Menu Response"
  325.             SysMenuDisable Me, 2001
  326.             End If
  327.         If wParam = 2003 Then
  328.             TheMsg$ = "This is test #3..." + nl + nl
  329.             TheMsg$ = TheMsg$ + "You can do anything here as well." + nl + nl
  330.             TheMsg$ = TheMsg$ + "'This is test #1' is ENABLED!"
  331.             MsgBox TheMsg$, 48, "Custom System Menu Response"
  332.             SysMenuEnable Me, 2001
  333.             End If
  334.         End If
  335. End Sub
  336.  
  337. Sub mnuDemos_Click ()
  338.     mnuDemosMoveControl.Enabled = True
  339.     If DisplayedMoveCtl = True Then
  340.         If MoveCtl.WindowState = 0 Then
  341.             mnuDemosMoveControl.Enabled = False
  342.             End If
  343.         End If
  344. End Sub
  345.  
  346. Sub mnuDemosExit_Click ()
  347.     End
  348. End Sub
  349.  
  350. Sub mnuDemosMoveControl_Click ()
  351.     If DisplayedMoveCtl = True Then
  352.         MoveCtl.SetFocus
  353.         MoveCtl.WindowState = 0
  354.         Else
  355.         Screen.MousePointer = 11
  356.         MoveCtl.Show
  357.         End If
  358. End Sub
  359.  
  360. Sub mnuDemosMoveForm_Click ()
  361.     Screen.MousePointer = 11
  362.     FormMove.Show 1
  363. End Sub
  364.  
  365. Sub mnuHelpAbout_Click ()
  366.     Screen.MousePointer = 11
  367.     About.Show 1
  368. End Sub
  369.  
  370. Sub mnuHelpCatalog_Click ()
  371.         On Error Resume Next
  372.         WinPath$ = GetWinDir()
  373.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  374.         DocPath$ = App.Path
  375.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  376.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  377.             End If
  378.         DocPath$ = BackSlashAdd(DocPath$) + "DPCT0195.WRI"
  379.         FullPath$ = WinPath$ + " " + DocPath$
  380.         Screen.MousePointer = 11
  381.         x = Shell(FullPath$, 3)
  382.         Screen.MousePointer = 0
  383. End Sub
  384.  
  385. Sub mnuHelpContents_Click ()
  386.     On Error Resume Next
  387.     MyHelpFile$ = App.Path
  388.     MyHelpFile$ = BackSlashAdd(MyHelpFile$) + "MESSAGE.HLP"
  389.     Screen.MousePointer = 11
  390.     ret% = WinHelp(Me.hWnd, MyHelpFile$, HELP_CONTENTS, 0&)
  391.     Screen.MousePointer = 0
  392. End Sub
  393.  
  394. Sub mnuHelpEval_Click ()
  395.         On Error Resume Next
  396.         WinPath$ = GetWinDir()
  397.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  398.         DocPath$ = App.Path
  399.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  400.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  401.             End If
  402.         DocPath$ = BackSlashAdd(DocPath$) + "EVALFRM.WRI"
  403.         FullPath$ = WinPath$ + " " + DocPath$
  404.         Screen.MousePointer = 11
  405.         x = Shell(FullPath$, 3)
  406.         Screen.MousePointer = 0
  407. End Sub
  408.  
  409. Sub mnuHelpOrder_Click ()
  410.         On Error Resume Next
  411.         WinPath$ = GetWinDir()
  412.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  413.         DocPath$ = App.Path
  414.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  415.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  416.             End If
  417.         DocPath$ = BackSlashAdd(DocPath$) + "ORDERFRM.WRI"
  418.         FullPath$ = WinPath$ + " " + DocPath$
  419.         Screen.MousePointer = 11
  420.         x = Shell(FullPath$, 3)
  421.         Screen.MousePointer = 0
  422. End Sub
  423.  
  424. Sub mnuHelpReg_Click ()
  425.         On Error Resume Next
  426.         WinPath$ = GetWinDir()
  427.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  428.         DocPath$ = App.Path
  429.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  430.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  431.             End If
  432.         DocPath$ = BackSlashAdd(DocPath$) + "OnlineRg.WRI"
  433.         FullPath$ = WinPath$ + " " + DocPath$
  434.         Screen.MousePointer = 11
  435.         x = Shell(FullPath$, 3)
  436.         Screen.MousePointer = 0
  437. End Sub
  438.  
  439. Sub mnuHelpSearch_Click ()
  440.     On Error Resume Next
  441.     MyHelpFile$ = App.Path
  442.     MyHelpFile$ = BackSlashAdd(MyHelpFile$) + "MESSAGE.HLP"
  443.     Screen.MousePointer = 11
  444.     ret% = WinHelp(Me.hWnd, MyHelpFile$, HELP_PARTIALKEY, "")
  445.     Screen.MousePointer = 0
  446. End Sub
  447.  
  448. Sub mnuHelpShareware_Click ()
  449.         On Error Resume Next
  450.         WinPath$ = GetWinDir()
  451.         WinPath$ = BackSlashAdd(WinPath$) + "WRITE.EXE"
  452.         DocPath$ = App.Path
  453.         If InStr(DocPath$, "\VB\DPTOOLS") Then
  454.             DocPath$ = Left$(DocPath$, 2) + "\VB\DPTOOLS"
  455.             End If
  456.         DocPath$ = BackSlashAdd(DocPath$) + "SHARWARE.WRI"
  457.         FullPath$ = WinPath$ + " " + DocPath$
  458.         Screen.MousePointer = 11
  459.         x = Shell(FullPath$, 3)
  460.         Screen.MousePointer = 0
  461. End Sub
  462.  
  463. Sub PicStatus_Paint ()
  464.     DoPicture3D PicStatus, "raised", 2, 0
  465.     
  466.     DoPicChild3D LblStatus, "sunken", 1
  467.     DoPicChild3D LblSBtime, "sunken", 1
  468.     DoPicChild3D LblSBdate, "sunken", 1
  469.     DoPicChild3D LblSBnum, "sunken", 1
  470.     DoPicChild3D LblSBcaps, "sunken", 1
  471. End Sub
  472.  
  473. Sub PicStatus_Resize ()
  474.     LblSBnum.Left = PicStatus.Width - 780
  475.     LblSBcaps.Left = LblSBnum.Left - 720
  476.     
  477.     PicStatus.Cls
  478.     PicStatus_Paint
  479. End Sub
  480.  
  481. Sub Timer1_Timer ()
  482.     'StatusBar Time
  483.     ThisTime$ = LCase$(Format$(Now, "medium time"))
  484.     If Left$(ThisTime$, 1) = "0" Then
  485.         ThisTime$ = Right$(ThisTime$, Len(ThisTime$) - 1)
  486.         End If
  487.     LblSBtime.Caption = ThisTime$
  488.     
  489.     'StatusBar Date
  490.     ThisDate$ = Format$(Now, "medium date")
  491.     ThisDate$ = replace(ThisDate$, "-", " ")
  492.     LblSBdate.Caption = ThisDate$
  493.  
  494.     'NumLock
  495.     If GetStateOfKey("NumLock") Then
  496.         LblSBnum.Caption = "NUM"
  497.         Else
  498.         LblSBnum.Caption = ""
  499.         End If
  500.     
  501.     'CapsLock
  502.     If GetStateOfKey("CapsLock") Then
  503.         LblSBcaps.Caption = "CAPS"
  504.         Else
  505.         LblSBcaps.Caption = ""
  506.         End If
  507. End Sub
  508.  
  509.